Option Explicit

Dim url, dirPath, suffix, html, urls

' 输入处理
url = Trim(InputBox("请输入网址："))
If url = "" Then WScript.Quit
dirPath = Trim(InputBox("请输入文件路径："))
If dirPath = "" Then WScript.Quit
suffix = Trim(InputBox("请输入后缀："))
If suffix = "" Then WScript.Quit
suffix = LCase(suffix)

On Error Resume Next

html = FetchHtml(url)
If Err.Number <> 0 Then
    WScript.Echo "获取网页失败：" & Err.Description
    WScript.Quit
End If

urls = ExtractUrls(html, suffix)
If Err.Number <> 0 Then
    WScript.Echo "提取URL失败：" & Err.Description
    WScript.Quit
End If

DownloadUrls urls, dirPath
If Err.Number <> 0 Then
    WScript.Echo "下载失败：" & Err.Description
End If

WScript.Echo "操作完成"

Function FetchHtml(url)
    Dim http
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open "GET", url, False
    http.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/91.0.4472.124 Safari/537.36"
    http.Option(4) = 13056
    http.SetTimeouts 10000, 10000, 10000, 10000
    http.Send
    If http.Status <> 200 Then Err.Raise 1, , "HTTP错误：" & http.Status
    FetchHtml = http.ResponseText
End Function

Function ExtractUrls(html, suffix)
    Dim regex, matches, arr(), i
    Set regex = New RegExp
    regex.Pattern = "https?://[^\s""'<>]+?\." & EscapeRegExp(suffix)
    regex.IgnoreCase = True
    regex.Global = True
    Set matches = regex.Execute(html)
    ReDim arr(matches.Count - 1)
    For i = 0 To matches.Count - 1
        arr(i) = matches(i).Value
    Next
    ExtractUrls = arr
End Function

Sub DownloadUrls(urls, dirPath)
    Dim fso, urlStr, http, stream, fileName
    Set fso = CreateObject("Scripting.FileSystemObject")
    CreateFullPath dirPath

    For Each urlStr In urls
        On Error Resume Next
        
        
        Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
        http.Open "GET", urlStr, False
        http.Send
        
        ' 修改点：使用条件判断代替Continue For
        If http.Status = 200 Then
            fileName = GetFileName(urlStr)
            SaveBinaryData fso.BuildPath(dirPath, fileName), http.ResponseBody
            
            If Err.Number = 0 Then
                
            Else
                WScript.Echo "保存失败: " & Err.Description
                Err.Clear
            End If
        Else
            WScript.Echo "下载失败: HTTP " & http.Status
        End If
    Next
End Sub

Function GetFileName(url)
    Dim path, pos, fileName
    path = Split(Split(url, "?")(0), "#")(0)
    pos = InStrRev(path, "/")
    If pos > 0 And pos < Len(path) Then
        fileName = Mid(path, pos + 1)
    Else
        fileName = "file_" & Replace(FormatDateTime(Now, 0), ":", "") & "." & suffix
    End If
    GetFileName = fileName
End Function

Sub SaveBinaryData(path, data)
    Dim stream
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1
    stream.Open
    stream.Write data
    stream.SaveToFile path, 2
    stream.Close
End Sub

Sub CreateFullPath(path)
    Dim fso, parts, fullPath
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(path) Then Exit Sub
    parts = Split(path, "\")
    fullPath = ""
    For Each part In parts
        fullPath = fullPath & part & "\"
        If Not fso.FolderExists(fullPath) Then fso.CreateFolder(fullPath)
    Next
End Sub

Function EscapeRegExp(text)
    Dim specialChars, i
    specialChars = Array(".", "^", "$", "*", "+", "?", "(", ")", "[", "]", "{", "}", "|", "\")
    For Each i In specialChars
        text = Replace(text, i, "\" & i)
    Next
    EscapeRegExp = text
End Function